perm filename RESTS.OLD[MSS,LCS]1 blob
sn#170761 filedate 1975-07-26 generic text, type T, neo UTF8
00100 SUBROUTINE RESTS
00200 COMMON/STF/RSTFAC(-3/4),RSTJ2 /XXX/LK,LP,JY
00300 COMMON/XRN/RN(2000),XN(2000)
00400 COMMON RS,JA,CENTR,J2,RQ(18),JX,JR,LX,RDIS
00500 COMMON/POSI/STFF(-3/4),JJ2,PQ/PTR/PWDS(250),L,LL,I,IX
00600 EQUIVALENCE (RQ(2),XLFT),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
00700 C RQ(2) IS R4, RQ(3) IS R5 ETC.
01000 REST=0
01100 CC DO 231 K=LX,L-1
01150 K=LX
01200 5 JL=PWDS(K)
01300 R=RN(JL+1)
01400 IF(R.NE.8)GO TO 232
01500 XLFT=RN(JL+3)
01600 GO TO 231
01700 232 IF(R.NE.2)GO TO 231
01800 IF(RN(JL).LT.6)GO TO 231
01900 C FOUND A WHOLE REST MEAS.
02000 IF(REST.NE.0)GO TO 6
02050 JR=JL+8
02060 C POINTER TO REST NUM.
02075 RN(JR-1)=RN(JR-1)*.6
02112 C REDUCE SIZE OF REST'S TIME SO IT WILL TAKE LESS SPACE.
02150 6 REST=REST+1
02200 RN(JR)=REST
02300 LB=PWDS(K+2)
02400 IF(RN(LB+1).NE.2)GO TO 233
02500 C NEXT IS TO COMBINE MEASURES OF REST
02600 IF(RN(LB).LT.6)GO TO 233
02605 C SKIP NON-WHOLE RESTS
02610 N=PWDS(K+1)
02620 IF(RN(N+1).NE.4)GO TO 233
02630 C IS REST FOLLOWED BY A BAR?
02700 CCC RN(LB+1)=0
02800 C SO IT WON'T BE FOUND NEXT TIME AROUND.
02900 RN(LB+3)=-99
03000 C MOVE IT FAR LET
03100 CCC LB=PWDS(K+1)
03200 RN(N+3)=-99
03300 C MOVES PPEV. BAR ALSO
03350 K=K+2
03400 GO TO 5
03500
03600 233 REST=0
03700 231 K=K+1
03750 IF(K.LT.L)GO TO 5
03800
03900 C NEXT DELETES UNWANTED ITEMS
04000 K=LX
04100 1 J=PWDS(K)
04110 RZ=RN(J+3)
04120 IF(RN(J+1).NE.5)GO TO 7
04130 C IS IT A SLUR?
04140 IF(RN(J+6).GT.200)RN(J+6)=199.99
04150 C .LT. XLFT IS OK FOR SLUR, BUT RT. SIDE MUST BE .LE. 200
04160 GO TO 2
04200 7 IF(RZ.GE.XLFT)GO TO 2
04300 N=PWDS(K+1)-J
04400 DO 3 M=J,IFIX(PWDS(L))
04500 3 RN(M)=RN(M+N)
04550 RZ=N
04600 DO 4 M=K+1,L-1
04700 4 PWDS(M)=PWDS(M+1)-RZ
04800 L=L-1
04850 JX=JX-1
04860 LK=LK-N
04870 LP=LK
04880 JY=LK
04890 C SHOULD THESE EVER BE DIFFERENT?????
04950 GO TO 1
04955
04960 2 IF(RZ.GT.200)RN(J+3)=200
04970 C NOTHING CAN START PAST 200.
05000 K=K+1
05100 IF(K.LT.L)GO TO 1
05200 END
05300
29000 FUNCTION R4567(R)
29100 R4567=0
29200 IF(R.LT.4)GO TO 1
29300 IF(R.LE.7)RETURN
29400 1 R4567=-1
29500 END
29600
29700 SUBROUTINE BMQ(RN,NZ,A)
29800 DIMENSION RN(1)
30000 RR=RN(NZ)
30100 IF(RR.LT.7)RETURN
30200 C FOR IRREGULAR BEAMS (THERE ARE AT LEAST 9 PARAMS.)
30300 IF(RR.NE.7)GO TO 129
30400 429 IF(RN(NZ+8).NE.0)GO TO 229
30500 RETURN
30600 129 IF(RN(NZ+10).EQ.0)GO TO 429
30700 IF(RN(NZ+10).LT.30)GO TO 229
30800 RB=RN(NZ+8)
30900 IF(RB.GT.A)RN(NZ+8)=BMX(RB,A)
31000 229 RB=RN(NZ+9)
31100 IF(RB.GT.A)RN(NZ+9)=BMX(RB,A)
31200 END
31300
31400 FUNCTION BMX(RB,A)
31410 COMMON /PX/POS,SX
31500 BMX=RB+SX
31600 IF(A.EQ.-1000.)BMX=POSX(RB)
31700 END
31800
32000 FUNCTION POSX(R)
32100 COMMON /PX/POS,SX
32200 POSX=POS+(R-POS)*SX
32300 END
32400
32500 FUNCTION RCLEF(R)
32600 DIMENSION R(1)
32700 RCLEF=0
32800 IF(R(2).NE.3)RETURN
32900 IF(R(1).LT.3)RETURN
33000 IF(R(6).LE.3)RETURN
33100 C FINDS ONLY 'REAL' CLEFS IN CODE NUM.3
33200 RCLEF=-1
33300 END